home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
forth
/
amiga
/
amigaker.arc
/
13.dict
< prev
next >
Wrap
Text File
|
1987-12-30
|
10KB
|
261 lines
;
; 13.dictionary
;
;
* traverse (s addr direction -- addr' ) Run through a name field
; in the specified direction ( +1 or -1 ) and return address of the fisrt
; byte whose high bit is set.
dc.w -1
dc.l link0
link0 set *-4
dc.b $88,'travers',$80!'e'
cnop 0,2
_traverse dc.l *+4
move.l (sp)+,d0
move.l (sp)+,a0
1$ adda.l d0,a0
tst.b (a0)
bpl.s 1$
move.l a0,-(sp)
jmp (a3)
* done? (s n -- f ) True if the input is exhausted or if
; the state doesn't match.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'done',$80!'?'
cnop 0,2
_done_question dc.l nest
dc.l _state,_fetch,_not_equals
dc.l _end_question,_fetch,_or
dc.l _end_question,_off,_exit
* n>link Go from name field to link field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $86,'n>lin',$80!'k'
cnop 0,2
_n_to_link dc.l nest
dc.l _4_minus,_exit
* l>name Go from link field to name field.
dc.w -1
dc.l link0
link0 set *-4
dc.b $86,'l>nam',$80!'e'
cnop 0,2
_l_to_name dc.l nest
dc.l _4_plus,_exit
* body> Go from body to code field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'body',$80!'>'
cnop 0,2
_body_from dc.l nest
dc.l _4_minus,_exit
* name> Go from name to code field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'name',$80!'>'
cnop 0,2
_name_from dc.l nest
dc.l _1,_traverse,_1_plus
dc.l _even,_exit
* link> Go from link field to code field.
dc.w -1
dc.l link0
link0 set *-4
dc.b $85,'link',$80!'>'
cnop 0,2
_link_from dc.l nest
dc.l _l_to_name,_name_from,_exit
* >body Go from code field to body.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'>bod',$80!'y'
cnop 0,2
_to_body dc.l nest
dc.l _4_plus,_exit
* >name Go from code field to name field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'>nam',$80!'e'
cnop 0,2
_to_name dc.l nest
dc.l _minus_1,_traverse,_minus_1,_traverse,_exit
* >link Go from code field to link field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'>lin',$80!'k'
cnop 0,2
_to_link dc.l nest
dc.l _to_name,_n_to_link,_exit
* >view Go from code field to view field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'>vie',$80!'w'
cnop 0,2
_to_view dc.l nest
dc.l _to_link,_2_minus,_exit
* view> go from view field to code field.
dc.w -1
dc.l link2
link2 set *-4
dc.b $85,'view',$80!'>'
cnop 0,2
_view_from dc.l nest
dc.l _2_plus,_link_from,_exit
* hash (s string voc-ptr -- thread ) This word indexes the
; voc-ptr to point to the start of a vocabulary linked list. This hash
; function uses the first character of the string as the function.
; Currently only 4 links are used. The function uses the two lower bits
; as the index.
dc.w -1
dc.l link0
link0 set *-4
dc.b $84,'has',$80!'h'
cnop 0,2
_hash dc.l *+4
move.l (sp)+,d0 ;get voc-ptr
move.l (sp),a0 ;string
addq.l #1,a0 ;step over length
moveq #3,d1 ;prepare mask
and.b (a0),d1 ;mask of 3 bits in char
asl.l #2,d1 ;times 4
add.l d1,d0
move.l d0,(sp)
jmp (a3)
* (find) (s here lfa -- here false | cfa flag )
; Attempts to find a match between the string at here and the dictionary
; linked list lfa. If not found the string address is returned with a (0)
; false flag.
; If found the Code Field Address is returned together with +1 if the word
; is immediate, -1 if the word is not immediate.
dc.w -1
dc.l link0
link0 set *-4
dc.b $86,'(find',$80!')'
cnop 0,2
_nest_find dc.l *+4
move.l (sp),d0 ;get voc pointer
move.l d0,a0 ; generate flags
beq no ;no words in vocabulary
; start by checking the length of both words
1$ move.l 4(sp),a1 ;point to word
lea 4(a0),a2 ;point to voc-word
move.b (a1)+,d1 ;get length of both words
move.b (a2)+,d2
eor.b d2,d1
andi.b #$3f,d1 ;mask of 2 high bits
bne.s 3$
; check all characters in both words
2$ move.b (a1)+,d1 ;get next characters
move.b (a2)+,d2 ; high bit set is the end
eor.b d2,d1
lsl.b #1,d1
bne.s 3$ ;if not the same do next word
bcc.s 2$ ; not last char yet
; a match, save the cfa of the found word
move.w a2,d0 ;a2 points to past last char
lsr.w #1,d0 ; must round it up
bcc.s 4$
addq.l #1,a2
4$ move.l a2,4(sp) ;save cfa of found word
; check the immediate bit and return -1 if clear
moveq #immediate,d0 ;mask
and.b 4(a0),d0 ; length byte
beq yes ;non-immediate,return -1
moveq #1,d0
move.l d0,(sp)
jmp (a3) ;immediate return 1
; advance to next word in vocabulary
3$ move.l (a0),d0
move.l d0,a0 ;check for zero
bne.s 1$
bra no ;return 0 if it is.
* #threads (s -- #threads ) Currently 4 linked lists.
dc.w -1
dc.l link3
link3 set *-4
dc.b $88,'#thread',$80!'s'
cnop 0,2
_number_threads dc.l doconstant,4
* find (s addr -- addr false | cfa flag ) Returns the same as
; (find). This word searches through the context array of vocabularies.
; Note that if the string is null, the address of 'noop' is returned
; marked as immediate, and 'end' is set on, to indicate to the interpreter
; or compiler, that the input is ended.
dc.w -1
dc.l link2
link2 set *-4
dc.b $84,'fin',$80!'d'
cnop 0,2
_find dc.l nest
dc.l _dup,_c_fetch
dc.l _question_branch,5$
dc.l _prior,_off,_false,_number_vocs,_0
dc.l _nest_do,4$
1$ dc.l _drop,_context,_i,_4_times
dc.l _plus,_fetch,_dup
dc.l _question_branch,3$
dc.l _dup,_prior,_fetch,_over
dc.l _prior,_store,_equals
dc.l _question_branch,2$
dc.l _drop,_false
dc.l _branch,3$
2$ dc.l _over,_swap,_hash,_fetch
dc.l _nest_find,_dup,_nest_question_leave
3$ dc.l _nest_loop,1$
4$ dc.l _branch,6$
5$ dc.l _drop,_end_question,_on
dc.l _nest_lit,_noop,_1
6$ dc.l _exit
* ?uppercase (s addr -- addr ) Convert string at address to upper case
; if caps is true.
dc.w -1
dc.l link3
link3 set *-4
dc.b $8a,'?uppercas',$80!'e'
cnop 0,2
_question_uppercase
dc.l nest
dc.l _caps,_fetch,_question_branch,1$
dc.l _dup,_count,_upper
1$ dc.l _exit
* defined (s -- here 0 | cfa [ -1 | +1 ] )
; Look up the next word in the input stream. Take case into account
; and return flag, and maybe cfa.
dc.w -1
dc.l link0
link0 set *-4
dc.b $87,'define',$80!'d'
cnop 0,2
_defined dc.l nest
dc.l _bl,_word,_question_uppercase,_find,_exit